home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 11 / CU Amiga Magazine's Super CD-ROM 11 (1997)(EMAP Images)(GB)(Track 1 of 3)[!][issue 1997-06].iso / cucd / programming / oberonv4 / source / system / class.mod (.txt) < prev    next >
Oberon Text  |  1995-12-26  |  9KB  |  267 lines
  1. Syntax10.Scn.Fnt
  2. Syntax10i.Scn.Fnt
  3. Syntax10b.Scn.Fnt
  4. MODULE Class;    (** HM 16-May-91 **)
  5. (*---------------------------------------------------------------------
  6. Extracts class interfaces from a source module (record types with type-bound procedures)
  7. Class.Show *
  8.     shows the interface of all record types in the marked source text.
  9. Class.Show modulename.typename
  10.     shows the interface of the specified type.
  11. Class.Show ^
  12.     shows the interface of the specified type. The selection may be
  13.     - a type name directly in the source text.
  14.     - a combination modulename.typename in any text.
  15. ----------------------------------------------------------------------*)
  16.     IMPORT
  17.         Oberon, Viewers, Texts, TextFrames, MenuViewers;
  18.     CONST
  19.         StdMenu = "System.Close  System.Copy  System.Grow  Edit.Search  Edit.Store";
  20.         TAB = 9X;  CR = 0DX;
  21.         eot = 0; procedure = 1;  record = 2;  pointer = 3;  end = 4; colon = 5;
  22.         lparen = 6;  rparen = 7;  semicolon = 8; eql = 9; arrow = 10; star = 11;
  23.         ident = 12; none = 99;
  24.     TYPE
  25.         Name = ARRAY 64 OF CHAR;
  26.         Class = POINTER TO ClassDesc;
  27.         Method = POINTER TO MethodDesc;
  28.         ClassDesc = RECORD
  29.             name: Name;
  30.             kind: INTEGER;
  31.             beg, end: LONGINT;
  32.             methods: Method;
  33.             link, next: Class
  34.         END;
  35.         MethodDesc = RECORD
  36.             beg, end: LONGINT;
  37.             next: Method
  38.         END;
  39.         ch: CHAR;
  40.         sym, lastSym: INTEGER;
  41.         pos, lastPos: LONGINT;
  42.         B: Texts.Buffer;
  43.         TMod, TOut: Texts.Text;
  44.         R: Texts.Reader;
  45.         W: Texts.Writer;
  46.         id: Name;
  47.         lineBeg: LONGINT;
  48.         lastID: Name;
  49.         lastIDline: LONGINT;
  50.         type: Name;
  51.         classes: Class;
  52. (* scanner *)
  53.     PROCEDURE Ch;
  54.     BEGIN
  55.         Texts.Read(R, ch); INC(pos)
  56.     END Ch;
  57.     PROCEDURE Start(n: LONGINT);
  58.     BEGIN
  59.         pos := n; Texts.OpenReader(R, TMod, pos)
  60.     END Start;
  61.     PROCEDURE Comment;
  62.     BEGIN
  63.         LOOP
  64.             IF R.eot THEN RETURN
  65.             ELSIF ch = "*" THEN Ch; IF ch = ")" THEN Ch; RETURN END
  66.             ELSIF ch = "(" THEN Ch; IF ch = "*" THEN Ch; Comment END
  67.             ELSE Ch
  68.             END
  69.         END
  70.     END Comment;
  71.     PROCEDURE Ident;
  72.         VAR i: INTEGER;
  73.     BEGIN sym := ident; i := 0;
  74.         REPEAT id[i] := ch; Ch; INC(i) UNTIL (ch < "0") & (ch # ".") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z");
  75.         id[i] := 0X
  76.     END Ident;
  77.     PROCEDURE Sym;
  78.         VAR ch0: CHAR;
  79.     BEGIN
  80.         lastSym := sym; lastPos := pos; sym := none;
  81.         WHILE sym = none DO
  82.             CASE ch OF
  83.             |  0X: sym := eot
  84.             |  1X.." ": REPEAT IF ch = CR THEN lineBeg := pos END; Ch UNTIL (ch > " ") OR (ch = 0X)
  85.             |  "a".."z", "A".."Z": Ident;
  86.                     CASE id[0] OF
  87.                     | "E": IF id = "END" THEN sym := end END
  88.                     | "P": IF id = "PROCEDURE" THEN sym := procedure ELSIF id = "POINTER" THEN sym := pointer END
  89.                     | "R": IF id = "RECORD" THEN sym := record END
  90.                     ELSE
  91.                     END;
  92.                     IF sym = ident THEN lastID := id; lastIDline := lineBeg END
  93.             |  "'", '"': ch0 := ch; REPEAT Ch UNTIL (ch = ch0) OR (ch < " ") OR R.eot; Ch
  94.             |  "(": Ch; IF ch = "*" THEN Ch; Comment ELSE sym := lparen END
  95.             |  ")": sym := rparen; Ch
  96.             |  ":": sym := colon; Ch
  97.             | "=": sym := eql; Ch
  98.             |  ";": sym := semicolon; Ch
  99.             | "^": sym := arrow; Ch
  100.             | "*": sym := star; Ch
  101.             ELSE Ch
  102.             END
  103.         END
  104.     END Sym;
  105. (* parser *)
  106.     PROCEDURE FindClass(VAR id: Name; VAR c: Class);
  107.     BEGIN c := classes;
  108.         WHILE (c # NIL) & (c.name # id) DO c := c.next END
  109.     END FindClass;
  110.     PROCEDURE FindLink(VAR id: Name; VAR c: Class);
  111.         VAR p: Class;
  112.     BEGIN p := classes;
  113.         WHILE (p # NIL) & ((p.link = NIL) OR (p.link.name # id)) DO p := p.next END;
  114.         IF p = NIL THEN c := NIL ELSE c := p.link END
  115.     END FindLink;
  116.     PROCEDURE RecordType(VAR c: Class);
  117.         VAR ok: BOOLEAN; c0: Class;
  118.     BEGIN c := NIL;
  119.         ok := lastSym IN {eql, ident};
  120.         IF lastSym = eql THEN FindLink(lastID, c) END;
  121.         IF c = NIL THEN NEW(c); c.name := lastID; c.kind := record END;
  122.         c.beg := lastIDline;
  123.         LOOP Sym;
  124.             IF sym IN {end, eot} THEN c.end := lastPos - 1; EXIT
  125.             ELSIF sym = record THEN RecordType(c0) (*ignore nested records*)
  126.             END
  127.         END;
  128.         IF ~ok THEN c := NIL END
  129.     END RecordType;
  130.     PROCEDURE PointerType(VAR c: Class);
  131.         VAR ok: BOOLEAN; c0: Class;
  132.     BEGIN
  133.         ok := lastSym = eql;
  134.         NEW(c); c.name := lastID; c.kind := pointer; c.beg := lastIDline;
  135.         Sym; Sym;
  136.         IF sym = ident THEN
  137.             FindClass(id, c0);
  138.             IF c0 = NIL THEN NEW(c0); c0.name := id; c0.kind := record END;
  139.             c.link := c0; Sym; c.end := pos - 1;
  140.         ELSIF sym = record THEN
  141.             RecordType(c0); c.link := c0; c0.name := "";
  142.             c.end := lastPos - 1;
  143.             IF ok THEN c0.next := classes; classes := c0 END
  144.         ELSE ok := FALSE
  145.         END;
  146.         IF ~ok THEN c := NIL END
  147.     END PointerType;
  148.     PROCEDURE Procedure;
  149.         VAR m: Method; className: Name; c: Class;
  150.     BEGIN 
  151.         NEW(m); m.beg := pos-10;
  152.         Sym; IF sym # lparen THEN RETURN END;
  153.         REPEAT Sym UNTIL sym IN {colon, eot};
  154.         Sym; className := id;
  155.         REPEAT Sym UNTIL sym IN {lparen, semicolon, eot};
  156.         IF sym = lparen THEN REPEAT Sym UNTIL sym IN {rparen, eot};
  157.             Sym; IF sym = colon THEN Sym; Sym END
  158.         END;
  159.         m.end := pos - 1;
  160.         FindClass(className, c); IF c = NIL THEN RETURN END;
  161.         IF c.kind = pointer THEN c := c.link END;
  162.         m.next := c.methods; c.methods := m
  163.     END Procedure;
  164. (* output routines *)
  165.     PROCEDURE Wr(ch: CHAR);
  166.     BEGIN Texts.Write(W, ch); Texts.Append(TOut, W.buf)
  167.     END Wr;
  168.     PROCEDURE Str(s: ARRAY OF CHAR);
  169.     BEGIN Texts.WriteString(W, s); Texts.Append(TOut, W.buf)
  170.     END Str;
  171.     PROCEDURE Lead(pos: LONGINT): INTEGER;
  172.         VAR n: INTEGER;
  173.     BEGIN Start(pos); n := -1;
  174.         REPEAT Ch; INC(n) UNTIL (ch > " ") OR (ch = CR) OR R.eot;
  175.         RETURN n
  176.     END Lead;
  177.     PROCEDURE OutStretch(from, to: LONGINT; VAR ind, nLines: INTEGER; VAR leadCh: CHAR);
  178.         VAR lead, i: INTEGER; pos: LONGINT;
  179.     BEGIN
  180.         lead := Lead(from); nLines := 0;
  181.         REPEAT
  182.             ind := Lead(from) - lead; INC(nLines);
  183.             Start(from); FOR i := 1 TO lead DO Ch; INC(from) END;
  184.             IF ch = " " THEN leadCh := " " ELSE leadCh := TAB END;
  185.             pos := from;
  186.             WHILE (from < to) & (ch # CR) DO Ch; INC(from) END;
  187.             Texts.Save(TMod, pos, from, B); Texts.Append(TOut, B)
  188.         UNTIL from >= to;
  189.     END OutStretch;
  190.     PROCEDURE OutMethod(m: Method; ind: INTEGER; leadCh: CHAR);
  191.         VAR i, j: INTEGER; k: CHAR;
  192.     BEGIN
  193.         IF m # NIL THEN OutMethod(m.next, ind, leadCh);
  194.             FOR i := 1 TO ind DO Wr(leadCh) END;
  195.             OutStretch(m.beg, m.end, i, j, k); Wr(CR)
  196.         END;
  197.     END OutMethod;
  198.     PROCEDURE OutClass(c: Class);
  199.         VAR ind, nLines, i: INTEGER; leadCh: CHAR;
  200.     BEGIN
  201.         OutStretch(c.beg, c.end, ind, nLines, leadCh); Wr(CR);
  202.         IF nLines = 1 THEN INC(ind) END; 
  203.         IF (c.kind = pointer) & (c.link # NIL) THEN
  204.             IF c.link.name = "" THEN c := c.link ELSIF type # "" THEN OutClass(c.link); RETURN END
  205.         END;
  206.         IF c.kind = record THEN
  207.             OutMethod(c.methods, ind, leadCh);
  208.             Str("END;"); Wr(CR)
  209.         END
  210.     END OutClass;
  211.     PROCEDURE OutAll(c: Class);
  212.     BEGIN
  213.         IF c # NIL THEN OutAll(c.next);
  214.             IF c.name # "" THEN OutClass(c) END
  215.         END
  216.     END OutAll;
  217. (* main *)
  218.     PROCEDURE PrepName(s: ARRAY OF CHAR; VAR mod, type: ARRAY OF CHAR);
  219.         VAR i, j: INTEGER;
  220.     BEGIN i := 0;
  221.         REPEAT mod[i] := s[i]; INC(i) UNTIL (s[i-1] = 0X) OR (s[i-1] = ".");
  222.         IF s[i-1] = "." THEN mod[i] := "M"; mod[i+1] := "o"; mod[i+2] := "d"; mod[i+3] := 0X;
  223.             j := 0; REPEAT type[j] := s[i]; INC(i); INC(j) UNTIL s[i-1] = 0X
  224.         ELSE COPY(mod, type); mod[0] := 0X
  225.         END
  226.     END PrepName;
  227.     PROCEDURE Show*;    (** ( "*" | "^" | name ) **)
  228.         VAR S: Texts.Scanner; V: Viewers.Viewer; text: Texts.Text; Menu, Text: TextFrames.Frame; x, y: INTEGER;
  229.             selbeg, selend, time: LONGINT; c: Class; m: Method; mod: Name;
  230.     BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
  231.         IF (S.class = Texts.Char) & (S.c = "*") & (S.line = 0) THEN V := Oberon.MarkedViewer();
  232.             IF (V # NIL) & (V.dsc # NIL) & (V.dsc.next # NIL) & (V.dsc.next IS TextFrames.Frame) THEN
  233.                 TMod := V.dsc.next(TextFrames.Frame).text; type := ""
  234.             ELSE RETURN
  235.             END
  236.         ELSIF (S.class = Texts.Name) & (S.line = 0) THEN
  237.             PrepName(S.s, mod, type); TMod := TextFrames.Text(mod)
  238.         ELSE Oberon.GetSelection(text, selbeg, selend, time);
  239.             IF time > 0 THEN Texts.OpenScanner(S, text, selbeg); Texts.Scan(S);
  240.                 IF (S.class # Texts.Name) OR (S.line > 0) THEN RETURN END
  241.             ELSE RETURN
  242.             END;
  243.             PrepName(S.s, mod, type);
  244.             IF mod = "" THEN TMod := text ELSE TMod := TextFrames.Text(mod) END
  245.         END;
  246.         Start(0); Ch; sym := none; lineBeg := 0; lastID := ""; lastIDline := 0; lastSym := none; classes := NIL;
  247.         LOOP Sym;
  248.             CASE sym OF
  249.                 procedure: Procedure
  250.             | record: RecordType(c); IF c # NIL THEN c.next := classes; classes := c END
  251.             | pointer: PointerType(c); IF c # NIL THEN c.next := classes; classes := c END
  252.             | eot: EXIT
  253.             ELSE
  254.             END
  255.         END;
  256.         TOut := TextFrames.Text(""); NEW(B); Texts.OpenBuf(B);
  257.         Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
  258.         V := MenuViewers.New(TextFrames.NewMenu(type, StdMenu), TextFrames.NewText(TOut, 0),
  259.             TextFrames.menuH, x, y);
  260.         IF type = "" THEN OutAll(classes)
  261.         ELSE FindClass(type, c); IF c # NIL THEN OutClass(c) END
  262.         END;
  263.         TMod := NIL; TOut := NIL; B := NIL; classes := NIL
  264.     END Show;
  265. BEGIN Texts.OpenWriter(W)
  266. END Class.
  267.